home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / linker / link.ml next >
Encoding:
Text File  |  1993-09-24  |  3.7 KB  |  156 lines  |  [TEXT/MPS ]
  1. #open "sys";;
  2. #open "obj";;
  3. #open "const";;
  4. #open "misc";;
  5. #open "instruct";;
  6. #open "config";;
  7. #open "opcodes";;
  8. #open "symtable";;
  9. #open "reloc";;
  10. #open "emit_phr";;
  11. #open "patch";;
  12. #open "tr_const";;
  13.  
  14. (* Production of a bytecode executable file *)
  15.  
  16. (* First pass : determine which phrases are required *)
  17.  
  18. let missing_globals =
  19.     (hashtbl__new 263 : (qualified_ident, unit) hashtbl__t);;
  20.  
  21. let is_required = function
  22.     Reloc_setglobal id, _ ->
  23.       begin try
  24.         hashtbl__find missing_globals id; true
  25.       with Not_found ->
  26.         false
  27.       end
  28.   | _ ->
  29.       false
  30. ;;
  31.  
  32. let remove_required = function
  33.     Reloc_setglobal id, _ ->
  34.       hashtbl__remove missing_globals id
  35.   | _ ->
  36.       ()
  37. ;;
  38.  
  39. let add_required = function
  40.     Reloc_getglobal id, _ ->
  41.       hashtbl__add missing_globals id ()
  42.   | _ ->
  43.       ()
  44. ;;
  45.  
  46. let scan_phrase tolink phr =
  47.   if not phr.cph_pure or exists is_required phr.cph_reloc then begin
  48.     do_list remove_required phr.cph_reloc;
  49.     do_list add_required phr.cph_reloc;
  50.     phr :: tolink
  51.   end else
  52.     tolink
  53. ;;
  54.  
  55. let scan_file tolink name =
  56.   let truename = find_in_path name in
  57.   try
  58.     let inchan = open_in_bin truename in
  59.     let n = input_binary_int inchan in
  60.     seek_in inchan n;
  61.     let phrase_index = (input_value inchan : compiled_phrase list) in
  62.     let required = it_list scan_phrase [] phrase_index in
  63.     close_in inchan;
  64.     (truename, required)::tolink
  65.   with x ->
  66.     prerr_begline ">> Error on file ";
  67.     prerr_endline truename;
  68.     raise x
  69. ;;
  70.  
  71. let require_qualid qual id =
  72.   hashtbl__add missing_globals {qual=qual; id=id} ()
  73. ;;
  74.  
  75. (* Second pass : link in the required phrases. *)
  76.  
  77. let link_object outchan (truename, required) =
  78.   let inchan = open_in_bin truename in
  79.   try
  80.     do_list
  81.       (function phr ->
  82.         seek_in inchan phr.cph_pos;
  83.         let buff = create_string phr.cph_len in
  84.         fast_really_input inchan buff 0 phr.cph_len;
  85.         patch_object buff 0 phr.cph_reloc;
  86.         output outchan buff 0 phr.cph_len)
  87.       required;
  88.     close_in inchan
  89.   with x ->
  90.     prerr_begline ">> Error while linking file ";
  91.     prerr_endline truename;
  92.     close_in inchan;
  93.     raise x
  94. ;;
  95.  
  96. (* To build the initial table of globals *)
  97.  
  98. let emit_data outstream =
  99.   let globals = make_vect (number_of_globals()) (repr 0) in
  100.   do_list
  101.     (function (n,sc) -> globals.(n) <- transl_structured_const sc)
  102.     !literal_table;
  103.   output_value outstream globals
  104. ;;
  105.  
  106. (* To build a bytecode executable file *)
  107.  
  108. let write_symbols = ref false;;
  109.  
  110. let link module_list exec_name =
  111.   let tolink =
  112.     it_list scan_file [] (rev module_list) in
  113.   let outchan =
  114.     open_out_gen
  115.       [O_WRONLY; O_TRUNC; O_CREAT; O_BINARY]
  116.       (s_irall + s_iwall + s_ixall)
  117.       exec_name in
  118.   try
  119.       (* The header *)
  120.     begin try
  121.       let inchan = open_in_bin (filename__concat !path_library "header") in
  122.       let buff = create_string 4096 in
  123.       let rec copy () =
  124.         match input inchan buff 0 4096 with
  125.           0 -> ()
  126.         | n -> output outchan buff 0 n; copy() in
  127.       copy()
  128.     with Sys_error _ ->
  129.       ()
  130.     end;
  131.       (* The bytecode *)
  132.     let pos1 = pos_out outchan in
  133.     do_list (link_object outchan) tolink;
  134.     output_byte outchan STOP;
  135.       (* The table of global data *)
  136.     let pos2 = pos_out outchan in
  137.     emit_data outchan;
  138.       (* Linker tables *)
  139.     let pos3 = pos_out outchan in
  140.     if !write_symbols then save_linker_tables outchan;
  141.       (* Debugging info (none, presently) *)
  142.     let pos4 = pos_out outchan in
  143.       (* The trailer *)
  144.     output_binary_int outchan (pos2 - pos1);
  145.     output_binary_int outchan (pos3 - pos2);
  146.     output_binary_int outchan (pos4 - pos3);
  147.     output_binary_int outchan 0;
  148.     output_string outchan "CL06";
  149.     close_out outchan
  150.   with x ->
  151.     remove_file exec_name;
  152.     close_out outchan;
  153.     raise x
  154. ;;
  155.  
  156.